Delphi 2 - Developers' Solutions/Delphi 2 Developers' Solutions.iso/dds/chap04/howto06/ccprnmgr.pas

Pascal/Delphi Source File | 1996-03-06 | 14.9 KB | 434 lines

unit Ccprnmgr;

interface

uses
  SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,
  Forms, Dialogs, StdCtrls, ExtCtrls, Buttons, Printers, DRWSUtl1;

type
  TCCPrintForm = class(TForm)
    ComboBox1: TComboBox;
    Label1: TLabel;
    BitBtn1: TBitBtn;
    BitBtn3: TBitBtn;
    BitBtn4: TBitBtn;
    Bevel1: TBevel;
    Label2: TLabel;
    Label3: TLabel;
    Label4: TLabel;
    Bevel2: TBevel;
    Label5: TLabel;
    Label6: TLabel;
    Bevel3: TBevel;
    ListBox1: TListBox;
    Label7: TLabel;
    BitBtn6: TBitBtn;
    BitBtn7: TBitBtn;
    BitBtn8: TBitBtn;
    Label8: TLabel;
    Label9: TLabel;
    Label10: TLabel;
    Label11: TLabel;
    RadioGroup1: TRadioGroup;
    BitBtn9: TBitBtn;
    FontDialog1: TFontDialog;
    BitBtn10: TBitBtn;
    BitBtn11: TBitBtn;
    BitBtn12: TBitBtn;
    PrintDialog1: TPrintDialog;
    PrinterSetupDialog1: TPrinterSetupDialog;
    procedure FormCreate(Sender: TObject);
    procedure BitBtn1Click(Sender: TObject);
    procedure BitBtn7Click(Sender: TObject);
    procedure BitBtn9Click(Sender: TObject);
    procedure RadioGroup1Click(Sender: TObject);
    procedure BitBtn6Click(Sender: TObject);
    procedure BitBtn4Click(Sender: TObject);
    procedure BitBtn8Click(Sender: TObject);
    procedure BitBtn10Click(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
    procedure HandlePrinting;
    procedure DumpScreenToPrinter;
  end;

var
  CCPrintForm: TCCPrintForm;

implementation

{$R *.DFM}

procedure TCCPrintForm.DumpScreenToPrinter;
var TheBitmap : TBitmap;
    ScreenDC : HDC;
    Info: PBitmapInfo;
    InfoSize: Integer;
    Image: Pointer;
    ImageSize: {Longint} Integer;
    Bits: HBITMAP;
    DIBWidth, DIBHeight: Longint;
    PrintWidth, PrintHeight: Longint;
    TheResult : Boolean;
    PrinterMult : Integer;
begin
  { External try/except loop to get errors }
  try
    { Start the print }
    Printer.BeginDoc;
    { Create the bitmap and put screen image in it }
    TheBitmap := TBitmap.Create;
    TheBitmap.Width := Screen.Width;
    TheBitmap.Height := Screen.Height;
    ScreenDC := GetDC( 0 );
    TheResult := BitBlt( TheBitmap.Canvas.Handle , 0 , 0 , Screen.Width , Screen.Height ,
            ScreenDC , 0 , 0 , SRCCOPY );
    ReleaseDC( 0 , ScreenDC );
    { Get the aspect ration printer to screen, less 1 for overruns }
    PrinterMult := Round( Printer.PageWidth / Screen.Width ) - 1;
    { Do a StretchDIBits due to a canvas bug in delphi printing }
    Bits := TheBitmap.Handle;
    GetDIBSizes(Bits, InfoSize, ImageSize);
    Info := MemAlloc(InfoSize);
    try
      Image := MemAlloc(ImageSize);
      try
        GetDIB(Bits, 0, Info^, Image^);
        with Info^.bmiHeader do
        begin
          DIBWidth := biWidth;
          DIBHeight := biHeight;
        end;
        PrintWidth := DIBWidth * PrinterMult;
        PrintHeight := DIBHeight * PrinterMult;
        StretchDIBits(Printer.Canvas.Handle, 10 , 10 , PrintWidth, PrintHeight, 0, 0,
         DIBWidth, DIBHeight, Image, Info^, DIB_RGB_COLORS, SRCCOPY);
      finally
          FreeMem(Image, ImageSize);
      end;
    finally
      FreeMem(Info, InfoSize);
    end;
    TheBitmap.Free;
    { Send the bitmap to the printer }
    if not Printer.Aborted then Printer.EndDoc;
  except
    { Assume HandlePrint reraises exception }
    On E:EPrinter do
    begin
      { Beep on error }
      MessageBeep( MB_ICONEXCLAMATION );
      { Set status label color to red }
      Label6.Font.Color := clRed;
      { Set the caption to the error message }
      Label6.Caption := E.Message;
      { If any exceptions occur chicken out and dump }
      Printer.Abort;
      exit;
    end;
    On E: Exception do
    begin
      raise;
      exit;
    end;
  end;
end;

procedure TCCPrintForm.HandlePrinting;
var TheFile      : TextFile;    { Used to open text files     }
    TheBitmap    : TBitmap;     { Used to open bitmap files   }
    Counter_1 ,                 { Loop Counter for Selections }
    Counter_2    : Integer;     { Loop Counter for lines      }
    TheString    : String;      { Text file IO handler        }
    TestString   : String;      { Used to check file extension}
    Info         : PBitmapInfo; { Used to print bitmap        }
    InfoSize     : Integer;     { Used to print bitmap        }
    Image        : Pointer;     { Used to print bitmap        }
    ImageSize    : {Longint} Integer;     { Used to print bitmap        }
    Bits         : HBITMAP;     { Used to print bitmap        }
    DIBWidth ,                  { Used to print bitmap        }
    DIBHeight    : Longint;     { Used to print bitmap        }
    PrintWidth ,                { Used to print bitmap        }
    PrintHeight  : Longint;     { Used to print bitmap        }
begin
  { Print text and bitmap files directly and shell all }
  { other files out to windows to print, if possible.  }
  for Counter_1 := 0 to Listbox1.Items.Count - 1 do
  begin
    { Allow checks for hitting abort button }
    Application.ProcessMessages;
    if Printer.Aborted then exit;
    { Check for selected file in the listbox to do a print }
    if ListBox1.Selected[ Counter_1 ] then
    begin
      { Check against extension of file selected }
      TestString := Uppercase( ExtractFileExt( ListBox1.Items[ Counter_1 ] ));
      if TestString = '.TXT' then
      begin { Print out text files directly to demo method }
        { Call begindoc method }
        Printer.BeginDoc;
        try
          { Try to assign and open the file, barf if can't }
          AssignFile( TheFile , ListBox1.Items[ Counter_1 ] );
          Reset( TheFile );
          { Set the lines printed counter }
          Counter_2 := 1;
          { Run to the end of the file }
          while not EOF( TheFile ) do
          begin
            { Allow the user to abort }
            Application.ProcessMessages;
            if Printer.Aborted then
            begin
              { Display brief abort message }
              Label6.Font.Color := clRed;
              Label6.Caption := 'Aborting...';
              Label6.Show;
              { Go bye bye }
              exit;
            end;
            { Do the actual printing with textout }
            { Read the next line in               }
            Readln( TheFile , TheString );
            { Put it out down the page per line }
            Printer.Canvas.TextOut( 10 , 20 +
             ( Counter_2  * ( Printer.Canvas.TextHeight( 'W' ) + 5 )) ,
              TheString );
            { Increment the line counter and test for end of page }
            Counter_2 := Counter_2 + 1;
            if (( Counter_2 * ( Printer.Canvas.TextHeight( 'W' ) +
             5 )) + 20 ) > ( Printer.PageHeight - 20 ) then
            begin
              { Send a form feed to printer and reset line counter }
              Printer.NewPage;
              Counter_2 := 1;
            end;
          end;
          { Close the file being printed }
          CloseFile( TheFile );
        except
          { Assume HandlePrint reraises exception }
          On E:EPrinter do
          begin
            { Beep on error }
            MessageBeep( MB_ICONEXCLAMATION );
            { Set status label color to red }
            Label6.Font.Color := clRed;
            { Set the caption to the error message }
            Label6.Caption := E.Message;
            { If any exceptions occur chicken out and dump }
            Printer.Abort;
            exit;
          end;
        end;
        { Call Enddoc method }
        Printer.EndDoc;
      end
      else
      begin
        if TestString = '.BMP' then
        begin { Print out bitmap files directly to demo method }
          { If not graphics capabile signal error }
          if Label9.Caption = 'Graphics Capable'
          then
          begin
            { Otherwise create the bitmap and load the file }
            TheBitmap := TBitmap.Create;
            try
              TheBitmap.LoadFromFile( ListBox1.Items[ Counter_1 ] );
            except
              { Abort on error }
              raise;
              exit;
            end;
            try
              { Start the printing }
              {Printer.BeginDoc;}
              { Perform magic since normal canvas stuff won't work! }
              with Printer, Canvas do
              begin
                { Get a handle to the bitmap's data }
                Bits := TheBitmap.Handle;
                { Find out memory requirements }
                GetDIBSizes(Bits, InfoSize, ImageSize);
                { Get a pointer to enough memory for structure }
                Info := MemAlloc(InfoSize);
                try
                  { Now try to hold the bits }
                  Image := MemAlloc(ImageSize);
                  try
                    { And conver them to Device Independent }
                    GetDIB(Bits, 0, Info^, Image^);
                    with Info^.bmiHeader do
                    begin
                      { Get width and height when done }
                      DIBWidth := biWidth;
                      DIBHeight := biHeight;
                    end;
                    { Set these to enlarge but could scale }
                    PrintWidth := DIBWidth * 3;
                    PrintHeight := DIBHeight * 3;
                    { Do actual print via StretchDIBits API call }
                    StretchDIBits(Canvas.Handle, 20 , 20 , PrintWidth,
                     PrintHeight, 0, 0, DIBWidth, DIBHeight, Image,
                      Info^, DIB_RGB_COLORS, SRCCOPY);
                  finally
                    { Release memory regardless }
                    FreeMem(Image, ImageSize);
                  end;
                finally
                  { Release more memory regardless }
                  FreeMem(Info, InfoSize);
                  { Free the bitmap }
                  TheBitmap.Free;
                end;
              end;
              { End the printing }
              Printer.EndDoc;
            except
              { Assume HandlePrint reraises exception }
              On E:EPrinter do
              begin
                { Beep on error }
                MessageBeep( MB_ICONEXCLAMATION );
                { Set status label color to red }
                Label6.Font.Color := clRed;
                { Set the caption to the error message }
                Label6.Caption := E.Message;
                { If any exceptions occur chicken out and dump }
                Printer.Abort;
                exit;
              end;
            end;
          end
          { Complain about printing to nonraster device! }
          else MessageDlg( 'Cannot Print A Bitmap On Non-Graphics Printer!',
           mtError, [mbOK],0 );
        end
        else
        begin
          { Otherwise try to shell out to windows to print complex file }
          if not ShellExec( ExpandFileName( ListBox1.Items[ Counter_1 ] )
            , '' , '', true , SW_SHOWMINIMIZED , true ) then
            MessageDlg('Could not Print ' + ListBox1.Items[ Counter_1 ] ,
             mtError, [mbOK], 0);
        end;
      end;
    end;
  end;
end;

procedure TCCPrintForm.FormCreate(Sender: TObject);
begin
  { Clear the combobox and assign the available printers }
  Combobox1.Clear;
  Combobox1.Items.Assign( Printer.Printers );
  Combobox1.Itemindex := Printer.PrinterIndex;
  { Display currently active printer }
  Label4.Caption := Printer.Printers[ Printer.PrinterIndex ];
  { Display resolution of currently active printer }
  Label11.Caption := 'Width: ' + InttoStr( Printer.PageWidth ) +
   ' Height: ' + IntToStr( Printer.PageHeight );
  { Display orientation of currently active printer }
  case Printer.Orientation of
    poPortrait  : RadioGroup1.ItemIndex := 0;
    poLandscape : RadioGroup1.ItemIndex := 1;
  end;
  { Set label for status }
  Label6.Font.Color := clBlack;
  Label6.Caption := 'Idle';
  { Determine basic device capabilities of the selected printer }
  if GetDeviceCaps( Printer.Handle , TECHNOLOGY ) = DT_RASPRINTER then
   Label9.Caption := 'Graphics Capable' else Label9.Caption := 'Character Device';
  if (( GetDeviceCaps( Printer.Handle , BITSPIXEL ) > 1 ) or
      ( GetDeviceCaps( Printer.Handle , PLANES    ) > 1 )) then
   Label8.Caption := 'Color Capable' else Label8.Caption := 'Monochrome';
  Label10.Caption := 'Resolution: ' +
   IntToStr( GetDeviceCaps( Printer.Handle , LOGPIXELSX )) + ' dpi';
end;

procedure TCCPrintForm.BitBtn1Click(Sender: TObject);
begin
  { Set the Default printer to be the selection of the combobox }
  Printer.PrinterIndex := ComboBox1.ItemIndex;
  { And cleverly reset the display! }
  FormCreate( Self );
end;

procedure TCCPrintForm.BitBtn7Click(Sender: TObject);
begin
  { This just runs the printer setup dialog }
  PrinterSetupDialog1.Execute;
end;

procedure TCCPrintForm.BitBtn9Click(Sender: TObject);
begin
  { This just displays available fonts for the printer }
  if FontDialog1.Execute then Printer.Canvas.Font := FontDialog1.Font;
end;

procedure TCCPrintForm.RadioGroup1Click(Sender: TObject);
begin
  { Set the printer orientation based on the radiogroup itemindex }
  case RadioGroup1.ItemIndex of
    0 : Printer.Orientation := poPortrait;
    1 : Printer.Orientation := poLandscape;
  end;
end;

procedure TCCPrintForm.BitBtn6Click(Sender: TObject);
begin
  { If execute print dialog then call HandlePrint method and deal with exceptions }
  if PrintDialog1.Execute then
  begin
    { Reset Label font color }
    Label6.Font.Color := clBlack;
    { Change status label to printing }
    Label6.Caption := 'Printing...';
    { Call HandlePrinting Method }
    HandlePrinting;
    { Reset the display to indicate printing not in progress }
    if Label6.Caption = 'Printing...' then Label6.Caption := 'Idle';
  end;
end;

procedure TCCPrintForm.BitBtn4Click(Sender: TObject);
begin
  { If already printing do abort }
  if Printer.Printing then
  begin
    { call abort method }
    Printer.Abort;
    { Reset status label }
    Label6.Font.Color := clBlack;
    Label6.Caption := 'Aborted...';
  end;
end;

procedure TCCPrintForm.BitBtn8Click(Sender: TObject);
begin
  if not ShellExec( 'C:\WINDOWS\EXPLORER.EXE', '' , '', false ,
   SW_SHOWNORMAL , false ) then
    MessageDlg('Could not locate Explorer!', mtError, [mbOK], 0);
end;

procedure TCCPrintForm.BitBtn10Click(Sender: TObject);
begin
  if PrintDialog1.Execute then
  begin
    { Reset Label font color }
    Label6.Font.Color := clBlack;
    { Change status label to printing }
    Label6.Caption := 'Printing...';
    { Call Print Screen Method }
    DumpScreenToPrinter;
    { Reset the display to indicate printing not in progress }
    if Label6.Caption = 'Printing...' then Label6.Caption := 'Idle';
  end;
end;

end.